#! /usr/bin/perl -w
use strict;

# =====================================================================================
#
#       Filename:  SourceAnalysis
#
#    Description:  Analysis the Progress source code and gives out improvement advice
#
#        Version:  1.0
#        Created:  2010/3/05 09:45:26
#       Revision:  1
#
#         Author:  Chao Meng (ycm), ycm@qad.com
#                   Copyright 1986-2010 QAD Inc., Santa Barbara, CA, USA. 
#
# =====================================================================================


# Helper Functions
sub Usage;
sub Message;
sub TestRegexWithErrMsgSgLine;
sub TestRegexWithErrMsgMtLine;

# Standard Check Functions
sub CheckFileFormat;            # File Format must be unix format other than dos format
sub CheckFileHead;              # Check whether the file header is correct (Just used in Report Convertion Project)
    sub CheckCopyRight;
    sub CheckReference;
sub CheckLineLength;            # Maximum acceptable Source Line Length - 80 characters
sub CheckTabs;                  # Check whether all the tabs have been converted to spaces
sub CheckTrailingSpaces;        # Check whether trailing spaces have been removed
sub CheckDebugCode;             # Check whether the Debugging Code "message" "display" "with frame" are removed
sub CheckUpperCaseSyntax;       # Capitalize 'PROCEDURE' 'END PROCEDURE', 'FUNCTION' 'END FUNCTION', 'CASE' 'END CASE'
sub CheckNoUndo;                # Check whether the variables or temp-tables are defined using 'no-undo'.
sub CheckFindStatement;         # Check whether all the "find [first/next]" statement is replaced with "for each/first"
sub CheckLogicalFilterValue;    # Check whether 'logical(GetFilterValue(...))' is replaced with "IsTrueValue(...)"
sub CheckBufferCopy;            # Use "no-error" with every "buffer-copy" statement
sub CheckDoBlock;               # Always use "do...end" block for "if...else" and "CASE...when" statement
sub CheckSessionDateFormat;     # Check whether session:date-format is set to "ymd" in order to process the search condition which has date format
sub CheckQueryClosed;           # Check every opened query object has been closed and deleted by the end of the procedure
sub CheckEndProcedure;          # Use "END PROCEDURE/FUNCTION" instead of just writing "END" to end a procedure/function
sub CheckDeadCode;              # Check Dead Code, used as unused variable, un-called procedure, function
    sub CheckUnusedVariable;        # Also Check the variable names are all lower-cased
    sub CheckUnusedProcedure;
sub CheckttFilterCondition;     # Do not use ttFilterCondition in your code


# Global Variable Definitions
our $iCurrLine;
our $iSeqNbr;
our @lines;

# Main Routine
if (@ARGV == 0)
{
    Usage();
}

while (@ARGV != 0)
{
    $iSeqNbr = 1;

    print "\nBegin Checking $ARGV[0] ......\n";

    open (SOURCEFILE, $ARGV[0])
        || die "Cannot open file $ARGV[0].";
    @lines = <SOURCEFILE>;

    # items to check
    &CheckFileFormat;
    &CheckFileHead;
    &CheckLineLength;
    &CheckTabs;
    &CheckTrailingSpaces;
    &CheckDebugCode;
    &CheckUpperCaseSyntax;
    &CheckNoUndo;
    &CheckFindStatement;
    &CheckLogicalFilterValue;
    &CheckBufferCopy;
    &CheckDoBlock;
    &CheckSessionDateFormat;
    &CheckQueryClosed;
    &CheckEndProcedure;
    &CheckDeadCode;
    &CheckttFilterCondition;

    close SOURCEFILE;
    print "End Checking $ARGV[0] ......\n\n";
    shift();
}

sub Usage
{
    die "Usage: SourceAnalysis file1 file2 ...\n";
}

sub Message
{
    my $msgStr = "$iSeqNbr.  ";
    my $lineCnt = "Line $iCurrLine:\t";
    my $msgContent = "$_[0]\n";
    if ($iCurrLine eq "")
    {
        $msgStr .= $msgContent;
    }
    else
    {
        $msgStr .= $lineCnt;
        $msgStr .= $msgContent;
    }
    print $msgStr;
    ++$iSeqNbr;
}

sub TestRegexWithErrMsgSgLine
{
    $iCurrLine = 0;
    my @number = map {++$iCurrLine; /$_[0]/ ? $iCurrLine:()} @lines;

    if (@number > 0)
    {
        $iCurrLine = join (", ", @number);
        &Message ("$_[1]");
    }
}

sub CheckFileFormat
{
    $iCurrLine = "";
    if ($lines[0] =~ /\r\n/)
    {
        &Message ("File Format must be unix format other than dos format");
    }
}

sub CheckFileHead 
{
    &CheckCopyRight;
    &CheckReference;
}

sub CheckCopyRight
{
    $iCurrLine = 2;
    if ($lines[$iCurrLine-1] =~ /Copyright 1986-(\d{4}) QAD Inc., (.*), CA, USA./)
    {
        (my $sec, my $min, my $hour, my $mday, my $mon, my $year, my $wday, my $yday, my $isdst) = localtime(time);
        $year = $year + 1900;
        if ("$1" ne "$year")
        {
            &Message ("Copyright Year Not Correct, should be: 1986-$year");
        }
        if ("$2" ne "Santa Barbara")
        {
            &Message ("Company Address Not Correct, should be: Santa Barbara");
        }
    }
    else
    {
        &Message ("Copyright Not Found in File Header");
    }
}

sub CheckReference
{
    $iCurrLine = 6;
    if ($lines[$iCurrLine-1] =~ /Report matches legacy (.+) for use by (.+)\./)
    {
        my $stg = $ENV{"STG"};
        if (not -f "$stg/$1")
        {
            &Message ("File $1 not exists in \$STG");
        }
        if ("$2" ne "QAD Reporting Framework")
        {
            &Message ("Please use: Report matches legacy ... for use by QAD Reporting Framework.");
        }
    }
    else
    {
        &Message ("Missing \"Report matches legacy xxxxxx.p\".");
    }
}

sub CheckLineLength
{
    $iCurrLine = 0;
    my $line;
    my $strMsg = "Exceed maximum acceptable Source Line Length - 80 characters: Line ";
    my $strCmp = $strMsg;
    foreach $line (@lines)
    {
        ++$iCurrLine;
        # Maxium allowed length 80 plus one "\n" character
        if (length ($line) > 81)
        {
            $strMsg .= $iCurrLine;
            $strMsg .= ", ";
        }
    }
    if ($strMsg ne $strCmp)
    {
        $strMsg = substr ($strMsg, 0, length($strMsg)-2);
        print "$iSeqNbr.  $strMsg\n";
        ++$iSeqNbr;
    }
}

sub CheckTabs
{
    &TestRegexWithErrMsgSgLine("\t", "Please replace <TAB> with white spaces.");
}

sub CheckTrailingSpaces
{
    &TestRegexWithErrMsgSgLine(" +\$", "Please remove trailing spaces in your proxy code.");
}

sub CheckDebugCode
{
    $iCurrLine = 0;
    my @number = map {++$iCurrLine; /\b(message|display|put|down|frame)\b/
        && !/\/\*.*(message|display|put|down|frame).*\*\// ? $iCurrLine:()} @lines;

    foreach $iCurrLine (@number)
    {
        &Message ("Please remove the Debugging Code!");
    }
}

sub CheckUpperCaseSyntax
{
    TestRegexWithErrMsgSgLine("^\\s*(procedure|end procedure|function|end function|case|end case)",
                              "Please Capitalize \'PROCEDURE\' \'END PROCEDURE\', \'FUNCTION\' \'END FUNCTION\', \'CASE\' \'END CASE\'");
}

sub CheckNoUndo
{
    $iCurrLine = 0;
    my @number = map {++$iCurrLine; /^\s*(define temp-table|define variable)/ && !/no-undo/ ? $iCurrLine:()} @lines;

    foreach $iCurrLine (@number)
    {
        &Message ("Please define variable or temp-table with \'no-undo\'");
    }
}

sub CheckFindStatement
{
    TestRegexWithErrMsgSgLine("^\\s*\\b(find|FIND)\\b",
                              "Please replace \'find [first/next]\' statement with \'for each/first\' statement");
}

sub CheckLogicalFilterValue
{
    TestRegexWithErrMsgSgLine("logical\\s*\\(GetFilterValue",
                              "Please replace \'logical(GetFilterValue(...))\' with \'IsTrueValue(...)\' function");
}

sub CheckBufferCopy
{
    $iCurrLine = 0;
    my @number = map {++$iCurrLine; /\s*buffer-copy/ && !/no-error/ ? $iCurrLine:()} @lines;

    foreach $iCurrLine (@number)
    {
        &Message ("Please use \'no-error\' with 'buffer-copy'");
    }
}

sub CheckDoBlock
{
    $iCurrLine = 0;
    # if this line isn't a comment and it has keyword "then" without "do" following it
    my @number = map {++$iCurrLine; !/\/\*.*then.*\*\// && /\bthen\b/ && !/then\s+\bdo\b/ ? $iCurrLine:()} @lines;

    foreach $iCurrLine (@number)
    {
      if ( $lines[$iCurrLine]  =~ /\.$/ )
        {
         &Message ("Please Always use \'do...end\' block for \'if...else\' statement");
      }
    }
}

sub CheckSessionDateFormat
{
    my @number = grep (/session:date-format\s+=\s+(\"|\')ymd(\"|\')/, @lines);
    my @conditions = grep (/(AddAllConditions)|(AddSomeConditions)/, @lines);
    if (0 == @number && @conditions > 0)
    {
        print "$iSeqNbr. session:date-format not set to \'ymd\' when processing filter condition of date format\n";
        ++$iSeqNbr;        
    }
}

sub CheckQueryClosed
{
    my @query_open = map {/(\S+):query-open()/i ? $1:()} @lines;
    my @query_close;
    my @query_delete;
    my $query_name;
    foreach $query_name (@query_open)
    {
        @query_close = grep (/${query_name}:query-close/i, @lines);
        if (0 == @query_close)
        {
            print "$iSeqNbr. Query $query_name opened without closed!\n";
            ++$iSeqNbr;
        }
        @query_delete = grep (/delete object $query_name/i, @lines);
        if (0 == @query_delete)
        {
            print "$iSeqNbr. Query $query_name opened without deleted!\n";
            ++$iSeqNbr;
        }
    }
}

sub CheckEndProcedure
{
    my @begin_procedure = grep (/^(PROCEDURE|FUNCTION)/i, @lines);
    my @end_procedure = grep (/^(END PROCEDURE|END FUNCTION)/i, @lines);

    if (@begin_procedure > @end_procedure)
    {
        print "$iSeqNbr. Please always use \'END PROCEDURE/FUNCTION\' instead of just writing \'END\' to end a procedure/function\n";
        ++$iSeqNbr;
    }
}

sub CheckttFilterCondition
{
    TestRegexWithErrMsgSgLine("ttFilterCondition",
                              "Please do not use \'ttFilterCondition\' in your proxy code.");
}

sub CheckDeadCode
{
    &CheckUnusedVariable;
    &CheckUnusedProcedure;
}

sub CheckUnusedVariable
{
    my @var_names = map {/define variable\s+(\S+)\s+/i ? $1:()} @lines;
    foreach my $var_name (@var_names)
    {
        my @var_used = grep (/\b${var_name}\b/, @lines);
        if (1 == @var_used)
        {
            print "$iSeqNbr. Variable $var_name defined without used!\n";
            ++$iSeqNbr;
        }
    }
}

sub CheckUnusedProcedure
{
    my @proc_names = map {/^(PROCEDURE|FUNCTION)\s+(\S+)/i ? $2:()} @lines;
    foreach my $proc_name (@proc_names)
    {
        my @proc_used = grep (/\b${proc_name}\b/, @lines);
        if (1 == @proc_used)
        {
            print "$iSeqNbr. PROCEDURE/FUNCTION $proc_name defined without used!\n";
            ++$iSeqNbr;
        }
    }
}

